home *** CD-ROM | disk | FTP | other *** search
/ Dr. Windows 3 / dr win3.zip / dr win3 / WINICONS / V12N11.ZIP / ABOUT.ZIP / ABOUT.PAS < prev    next >
Pascal/Delphi Source File  |  1993-03-31  |  9KB  |  317 lines
  1. {************************************************}
  2. {                                                }
  3. {   About box unit                               }
  4. {   Copyright (c) 1993 by Danny Thorpe           }
  5. {                                                }
  6. {   for Borland Pascal 7.0                       }
  7. {************************************************}
  8.  
  9. unit About;
  10.  
  11. interface
  12.  
  13. uses Winprocs, Wintypes, Objects, OWindows, ODialogs;
  14.  
  15. {$R About.res}
  16.  
  17. const
  18.   idShade = 100;
  19.   idBump  = 101;
  20.   idHotKey = 103;
  21.  
  22. type
  23.   PPCharArray = ^TPCharArray;
  24.   TPCharArray = array [0..65520 div sizeof(PChar)] of PChar;
  25.  
  26.   PCreditWindow = ^TCreditWindow;
  27.   TCreditWindow = object(TWindow)
  28.     Bitmap: HBitmap;
  29.     BitSize: TBitmap;
  30.     ScrollUnit: Integer;
  31.     ScrollRate: Integer;
  32.     ScrollPos: Integer;
  33.     FontHeight: Integer;
  34.     StringList: PPCharArray;
  35.     StringCount: Word;
  36.     constructor Init(AParent: PWindowsObject;
  37.                      ABitmapName: PChar;
  38.                      const AStringList: Array of PChar);
  39.     destructor Done; virtual;
  40.     function  GetClassName: PChar; virtual;
  41.     procedure GetWindowClass(var WC: TWndClass); virtual;
  42.     procedure SetupWindow; virtual;         { First place HWindow is valid }
  43.     procedure WMDestroy(var Msg: TMessage); { Last place HWindow is valid  }
  44.       virtual wm_First + wm_Destroy;
  45.     procedure Paint(DC: HDC; var PS: TPaintStruct); virtual;
  46.     procedure ShowCredits; virtual;
  47.     procedure WMTimer(var Msg: TMessage);
  48.       virtual wm_First + wm_Timer;
  49.   end;
  50.  
  51.   PAboutBox = ^TAboutBox;
  52.   TAboutBox = object(TDialog)
  53.     Title: PChar;
  54.     CreditWindow: PCreditWindow;
  55.     constructor Init(AParent: PWindowsObject;
  56.                      ATitle, ABitmapName: PChar;
  57.                      const AStringList: Array of PChar);
  58.     destructor Done; virtual;
  59.     procedure SetupWindow; virtual;
  60.     function  GetResName: PChar; virtual;
  61.     procedure InitCreditWindow(ABitmapName: PChar;
  62.                                const AStringList: array of PChar); virtual;
  63.     procedure ShowCredits(var Msg: TMessage);
  64.       virtual id_First + idHotKey;
  65.   end;
  66.  
  67. implementation
  68.  
  69. uses Strings;
  70.  
  71. constructor TCreditWindow.Init(AParent: PWindowsObject;
  72.                                ABitmapName: PChar;
  73.                                const AStringList: Array of PChar);
  74. var
  75.   DC: HDC;
  76.   OldFont: HFont;
  77.   TM: TTextMetric;
  78. begin
  79.   inherited Init(AParent, nil);
  80.   Attr.Style := ws_Child or ws_Visible;
  81.   Bitmap := LoadBitmap(HInstance, ABitmapName);
  82.   if Bitmap = 0 then
  83.   begin
  84.     Status := em_InvalidWindow;
  85.     Exit;
  86.   end;
  87.   GetObject(Bitmap, SizeOf(BitSize), @BitSize);
  88.   ScrollPos := 0;
  89.   DC := GetDC(0);
  90.   ScrollUnit := 2;
  91.   ScrollRate := 80;
  92.   OldFont := SelectObject(DC, GetStockObject(ANSI_VAR_FONT));
  93.   GetTextMetrics(DC, TM);
  94.   FontHeight := TM.tmHeight + TM.tmExternalLeading + 5;
  95.   SelectObject(DC, Oldfont);
  96.   ReleaseDC(0, DC);
  97.   StringList := @AStringList;
  98.   StringCount := High(AStringList)+1;
  99. end;
  100.  
  101. destructor TCreditWindow.Done;
  102. begin
  103.   inherited Done;
  104.   DeleteObject(Bitmap);
  105. end;
  106.  
  107. function TCreditWindow.GetClassName: PChar;
  108. begin
  109.   GetClassName := 'OWLAboutBitmap';
  110. end;
  111.  
  112. procedure TCreditWindow.GetWindowClass(var WC: TWndClass);
  113. begin
  114.   inherited GetWindowClass(WC);
  115.   WC.Style := cs_ByteAlignWindow;   { for BitBlt speed }
  116.   WC.hbrBackground := GetStockObject(Black_Brush);
  117. end;
  118.  
  119. procedure TCreditWindow.SetupWindow;
  120. begin
  121.   inherited SetupWindow;
  122.   SetWindowPos(HWindow, 0, 0, 0, BitSize.bmWidth, BitSize.bmHeight,
  123.                swp_NoMove or swp_NoZOrder or swp_NoActivate or swp_NoRedraw);
  124. end;
  125.  
  126. procedure TCreditWindow.WMDestroy(var Msg: TMessage);
  127. begin
  128.   if ScrollPos <> 0 then { We're scrolling and need to kill the timer }
  129.   begin
  130.     KillTimer(HWindow, 1);
  131.     ScrollPos := 0;
  132.   end;
  133.   inherited WMDestroy(Msg);
  134. end;
  135.  
  136. procedure TCreditWindow.Paint(DC: HDC; var PS: TPaintStruct);
  137. var
  138.   R: TRect;
  139.   FirstLine, LastLine, Y: Integer;
  140.  
  141.   procedure DrawBitmap(Y: Integer);
  142.   var
  143.     MemDC: HDC;
  144.     OldBits: HBitmap;
  145.   begin
  146.     MemDC:= CreateCompatibleDC(DC);
  147.     OldBits := SelectObject(MemDC, Bitmap);
  148.     BitBlt(DC, 0, Y, Attr.W, Attr.H, MemDC, 0, 0, srcCopy);
  149.     SelectObject(MemDC, OldBits);
  150.     DeleteDC(MemDC);
  151.   end;
  152.  
  153. begin
  154.   SaveDC(DC);
  155.   SetViewportOrg(DC, 0, -ScrollPos);
  156.   OffsetRect(PS.rcPaint, 0, ScrollPos);
  157.   with R do
  158.   begin
  159.     Left := 0;
  160.     Top := 0;
  161.     Right := Attr.W;
  162.     Bottom := Attr.H;
  163.   end;
  164.   if Bool(IntersectRect(R, PS.rcPaint, R)) then
  165.   begin
  166.     DrawBitmap(0);
  167.     with PS.rcPaint do
  168.     begin
  169.       if (R.Top < Top) and (R.Bottom > Top) then Top := R.Bottom;
  170.       if (R.Top < Bottom) and (R.Bottom > Bottom) then Bottom := R.Top;
  171.       if Top > Bottom then Top := Bottom;
  172.     end;
  173.   end;
  174.   if ScrollPos > 0 then    { we're scrolling }
  175.   begin
  176.     FirstLine := (PS.rcPaint.Top - Attr.H) div FontHeight;
  177.     if FirstLine < 0 then FirstLine := 0;
  178.     if FirstLine < StringCount then
  179.     begin                             { we have text to draw }
  180.       SetTextAlign(DC, TA_Center);
  181.       SetBkColor(DC, 0);
  182.       SetTextColor(DC, RGB($ff,$ff,$ff));
  183.       LastLine := (PS.rcPaint.Bottom - Attr.H) div FontHeight;
  184.       for Y := FirstLine to LastLine do
  185.         if Y < StringCount then
  186.           TextOut(DC, Attr.W div 2, Y*FontHeight + Attr.H,
  187.                       StringList^[Y], StrLen(StringList^[Y]));
  188.     end;
  189.                             { Paint second image of bitmap at bottom }
  190.     if PS.rcPaint.Bottom > (Attr.H+FontHeight*StringCount) then
  191.       DrawBitmap(Attr.H + FontHeight * StringCount);
  192.   end;
  193.   RestoreDC(DC, -1);
  194. end;
  195.  
  196. procedure TCreditWindow.ShowCredits;
  197. begin
  198.   SetTimer(HWindow, 1, ScrollRate, nil);
  199. end;
  200.  
  201. procedure TCreditWindow.WMTimer(var Msg: TMessage);
  202. begin
  203.   Inc(ScrollPos, ScrollUnit);
  204.   { Check to see if it's time to stop scrolling }
  205.   if ScrollPos > Attr.H + FontHeight * StringCount then
  206.   begin
  207.     ScrollPos := 0;
  208.     KillTimer(HWindow, 1);
  209.     InvalidateRect(HWindow, nil, False);
  210.   end
  211.   else
  212.     ScrollWindow(HWindow, 0, -ScrollUnit, nil, nil);
  213.   UpdateWindow(HWindow);
  214. end;
  215.  
  216. {*********************************************************}
  217.  
  218. constructor TAboutBox.Init(AParent: PWindowsObject;
  219.                            ATitle, ABitmapName: PChar;
  220.                            const AStringList: array of PChar);
  221. begin
  222.   inherited Init(AParent, GetResName);
  223.   Title := StrNew(ATitle);
  224.   InitCreditWindow(ABitmapName, AStringList);
  225. end;
  226.  
  227. destructor TAboutBox.Done;
  228. begin
  229.   inherited Done;
  230.   if Title <> nil then
  231.     StrDispose(Title);
  232. end;
  233.  
  234. procedure TAboutBox.SetupWindow;
  235. var
  236.   RDialog,R,RBitWnd,RShade,RBump,ROk: TRect;
  237.   X8, Y8: Integer;
  238.   DC: HDC;
  239. begin
  240.   inherited SetupWindow;
  241.   SetWindowText(HWindow, Title);
  242.   DC := GetDC(HWindow);
  243.   X8 := GetDeviceCaps(DC,LogPixelsX) div 8;   { 1/8 inch }
  244.   Y8 := GetDeviceCaps(DC,LogPixelsY) div 8;
  245.   ReleaseDC(HWindow, DC);
  246.   GetClientRect(GetDlgItem(HWindow, idShade), RShade);
  247.   GetClientRect(GetDlgItem(HWindow, idBump), RBump);
  248.   GetClientRect(GetDlgItem(HWindow, idOK), ROk);
  249.   GetClientRect(CreditWindow^.HWindow, RBitWnd);
  250.   RShade.Top := Y8;
  251.   RShade.Left := X8;
  252.   if RShade.Right < RBitWnd.Right + 2*X8 then
  253.     RShade.Right := RBitWnd.Right + 2*X8;
  254.   if RShade.Bottom < RBitWnd.Bottom + 2*Y8 then
  255.     RShade.Bottom := RBitWnd.Bottom + 2*Y8;
  256.  
  257.   with  RDialog do
  258.   begin
  259.     GetWindowRect(HWindow, RDialog);
  260.     GetClientRect(HWindow, R);
  261.     Right := Right - Left - R.Right;
  262.     Bottom := Bottom - Top - R.Bottom;
  263.     Right := Right + X8 + RShade.Right + X8;   { 1/8 inch margins }
  264.     Bottom := Bottom + Y8 + RShade.Bottom
  265.                      + Y8 + RBump.Bottom
  266.                      + Y8 + ROk.Bottom + Y8;
  267.     if Parent <> nil then
  268.     begin
  269.       GetWindowRect(Parent^.HWindow, R);
  270.         { Center dialog in parent's window }
  271.       Left := R.Left + (R.Right - R.Left) div 2 - Right div 2;
  272.       Top := R.Top + (R.Bottom - R.Top) div 2 - Bottom div 2;
  273.     end;
  274.     SetWindowPos(HWindow, 0, Left, Top, Right, Bottom,
  275.